COMMENT ⊗   VALID 00020 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	
C00004 00003	SIMPLE PROCEDURE STITINI
C00005 00004	! fluent_fact
C00006 00005	! affixed_to
C00007 00006	! csplit, stmchk, is_undef_sym_item
C00008 00007	! world assignment:  xxxwld, wldasg (lpbasg, parasg)
C00014 00008	! check_guards
C00015 00009	! mergein
C00016 00010	! cpattl
C00018 00011	! asrtit & denyit
C00021 00012	! new_fluent, new_set_fluent, new_var, new_exprn, stmake, new_stmnt
C00024 00013	! domove
C00026 00014	! do_affix, do_affix_stmnt, do_detach
C00030 00015	! blockdo & sttblk
C00032 00016	! Cobdo
C00033 00017	! loopbdo
C00034 00018	! statement interpreter: stinterp (owdo, iwcopy)
C00040 00019	! proc_form interpreter:  apfrm, apfrm2
C00041 00020	! test program
C00042 ENDMK
C⊗;

IFCR ¬DECLARATION(EXTENDED_COMPILATION) THENC
ENTRY;

BEGIN "WLDMOD"
IFCR ¬DECLARATION(CREFFING) THENC DEFINE CREFFING = FALSE;ENDC
IFCR ¬ CREFFING THENC
REQUIRE "HALREQ.HDR" SOURCE_FILE;
ENDC
DEFINE $$PRGID "[]" = ["WLDMOD"];
ENDC

REQUIRE 300 SYSTEM_PDL;

INTEGER STITRC;

RPTR(SPECVAL) VNEWTRANS;

PROCEDURE VNEWINI;
	BEGIN
	VNEWTRANS←NEW_RECORD(SPECVAL);
	SPECVAL:TYPE[VNEWTRANS]←TRANS_DTYPE;
	END;

REQUIRE VNEWINI INITIALIZATION;
SIMPLE PROCEDURE STITINI;
	BEGIN
	OUTSTR("
SET TRACE OPTIONS FOR STINTERP:
'1 -- print ""statement"" type
'2 -- print ""statement"" record
type in one fhq octal number:");
	STITRC←CVO(INCHWL);
	END;

! fluent_fact;

BOOLEAN PROCEDURE FLUENT_FACT(RPTR(FACT) F);
	BEGIN
	RANY PTN;
	PTN←FACT:PATT[F];
	IF RECLEN(PTN)≠2 THEN RETURN(FALSE);
	START_CODE "FLFSTC"
	LABEL XXX,XXX0;
	SKIPE	1,PTN;
	SKIPN	1,1(1);
	JRST	XXX;
	TLC	1,REC_CODE;
	TLNE	1,(PROCB+ARY2B+ITEMB+'3740);
	JRST	XXX0; ! false if first isn't ref(record);
	HRRZ	1,(1); ! point at record;
	HRRZ	1,(1); ! point at record type;
	CAIN	1,FLUENT;
XXX0:	TDZA	1,1;
	MOVEI	1,1;
XXX:	END;
	
	END;
! affixed_to;

BOOLEAN RECPROC AFFIXED_TO(RPTR(VARIABLE) V1,V2;ITEMVAR WLD);
	BEGIN
	RPTR(VARIABLE) V3,BYV,RGF;RPTR(TRANS) T;
	∀ | LPMATCH(WLD,\(AFFIXED,V1,∃ V3,∃ BYV,∃ T,∃ RGF) ) DO
		BEGIN
		IF V2=V3 THEN RETURN(TRUE);
		IF AFFIXED_TO(V3,V2,WLD) THEN RETURN(TRUE);
		END;
	∀ | LPMATCH(WLD,\(AFFIXED,∃ V3,V1,∃ BYV,∃ T,RIGIDLY) ) DO
		BEGIN
		IF V2=V3 THEN RETURN(TRUE);
		IF AFFIXED_TO(V3,V2,WLD) THEN RETURN(TRUE);
		END;
	RETURN(FALSE);
	END;

! csplit, stmchk, is_undef_sym_item;

SIMPLE ITEMVAR PROCEDURE CSPLIT(ITEMVAR IW;BOOLEAN NEWFG(TRUE));
	RETURN(IF NEWFG THEN NEWWLD ELSE IW);

! be sure S is a statement;

RPTR(STMNT) PROCEDURE STMCHK(RANY S);
	RETURN(CHKREC(S,LOC(STMNT)));

! world assignment:  xxxwld, wldasg (lpbasg, parasg);

SIMPLE ITEMVAR PROCEDURE XXXWLD(ITEMVAR INW;BOOLEAN CLANY(FALSE));
	BEGIN
        ! Makes a copy of the input world and returns it.  If CLANY
        is TRUE, then the "clear" field of the new world is set to
        ANY.  Otherwise, it is copied from the old world.;
	ITEMVAR OUW;
	OUW←NEWWLD;
	CLEAR[WLDINX(OUW)]←IF CLANY THEN ANY ELSE CLEAR[WLDINX(INW)];
	COPY_ALERTS(INW,OUW);
	RETURN(OUW);
	END;

INTERNAL RECURSIVE PROCEDURE WLDASG(RPTR(STMNT) S;
		ITEMVAR IW;REFERENCE ITEMVAR OW;REFERENCE BOOLEAN NFLAG);
	BEGIN
        !  Assigns worlds to statements associated with the statement
        S.  If NFLAG is true, then something or other special
        happens. (This flag is used to avoid assigning separate 
	worlds to successive assignment statements).
	No longer makes the variable list for blocks.
	;

	LABEL XIT;
	RANY SS;
	INTEGER ST;
	RCELL C;
	BOOLEAN NF;
	OWN INTEGER OFFST;  INITIALIZE(OFFST ← '20);
	    ! OFFST is used to generate variable offsets;

	RECPROC LPBASG(RPTR(STMNT) SS);
		BEGIN
		!  Handles the special case of a loop body;
		ITEMVAR IWW,WW;
		NF←TRUE;
		IWW←XXXWLD(IW,TRUE);
		WW←PREP_ALERT(IWW);
		CLEAR[WLDINX(IWW)]←WW;
		WLDASG(SS,IWW,OW,NF);
		OW←XXXWLD(IW);
		END;

	RECPROC PARASG(RCELL C);
		BEGIN
                ! CDRs down a list of statements that are meant to be
                parallel in execution, doing the world assignments.
                Assigns a world to the end as well;
		WHILE C≠NULL_RECORD DO
			BEGIN
			NF←TRUE;
			WLDASG(STMCHK(CELL:CAR[C]),XXXWLD(IW,TRUE),OW,NF);
			C←CELL:CDR[C];
			END;
		OW←XXXWLD(IW);
		END;

	SS←STMNT:SEMANTICS[S];
	ST←RECTYPE(SS);
	STMNT:IW[S]←IW;
	IF ST=0 THEN
		BEGIN
		OW←STMNT:OW[S]←IW;
		RETURN;
		END;
	IF ST=LOC(ASSERT)∨ST=LOC(DENY) THEN
		BEGIN
		IF ASSERT:WLD[SS]≠ANY THEN
			BEGIN
			OW←IW;
			END
		ELSE
			BEGIN
			OW←IF NFLAG THEN XXXWLD(IW) ELSE IW;
			ASSERT:WLD[SS]←OW;
			NFLAG←FALSE;
			END;
		STMNT:OW[S]←OW;
		RETURN;
		END
	ELSE IF ST=LOC(ASSIGNMENT)∨ST=LOC(GASSIGN) THEN
		BEGIN
		OW←STMNT:OW[S]←IF NFLAG THEN XXXWLD(IW) ELSE IW;
		NFLAG←FALSE;
		RETURN;
		END
	ELSE 
		NFLAG←TRUE;

	NF←TRUE;

	IF ST=LOC(BLOCK) THEN
		BEGIN "blkasg"
		RPTR(BLOCK) B;
		B←SS;
		C←BLOCK:CODE[B];
		OW←IW;
		WHILE C≠NULL_RECORD DO
			BEGIN
			SS←CELL:CAR[C];
			ST←RECTYPE(SS);
			IF ST=LOC(PVL)∨ST=LOC(DBD) THEN
				BEGIN
				END
			ELSE IF ST=LOC(VARIABLE) THEN
				BEGIN
				END
			ELSE IF ST=LOC(STMNT) THEN
				BEGIN "sasa"
				WLDASG(SS,OW,OW,NF);
				END;	
			C←CELL:CDR[C];
			END;
		END
	ELSE IF ST=LOC(COBLOCK) THEN
		BEGIN
		PARASG(COBLOCK:CODE[SS]);
		END
	ELSE IF ST=LOC(FORR) THEN
		LPBASG(FORR:BODY[SS])
	ELSE IF ST=LOC(WHIL) THEN
		LPBASG(WHIL:BODY[SS])
	ELSE IF ST=LOC(IFF) THEN
		BEGIN
		NF←TRUE;
		WLDASG(IFF:THN[SS],XXXWLD(IW,TRUE),OW,NF);
		NF←TRUE;
		WLDASG(IFF:ELS[SS],XXXWLD(IW,TRUE),OW,NF);
		OW←XXXWLD(IW);
		END
	ELSE IF ST=LOC(NW) THEN
		BEGIN
		NFLAG←FALSE;
		OW←NW:WLD[SS];
		IF OW=ANY THEN
			OW←XXXWLD(IW)
		ELSE
			BEGIN
			CLEAR[WLDINX(OW,-1)]←CLEAR[WLDINX(IW)];
			COPY_ALERTS(IW,OW);
			END;
		END
	ELSE IF ST=LOC(PROG) THEN
		BEGIN
		! **** Not sure what to do here with NFLAG & NF ****;
		WLDASG(PROG:CODE[SS],XXXWLD(IW,TRUE),OW,NF);
		END
	ELSE
		OW←XXXWLD(IW);
	STMNT:OW[S]←OW;
XIT:	END;

! check_guards;

PROCEDURE CHECK_GUARDS(ITEMVAR IW,OW);
	BEGIN
	RPTR(FACT) F;
	INTEGER OWX;
	ITEMVAR GW,WW;
	∀ WW | ALERT_ORDER⊗IW≡WW DO
		BEGIN
		GW←GUARD[WLDINX(WW)];
		IF GW=ANY THEN CONTINUE;
		∀ | GEN_FACTS(F,GW) DO
			BEGIN
			IF ¬TSTWIX(F,OWX) THEN
				BEGIN
				$PRINT(CRLF&"WARNING: ",TTYALWAYS);
				PRNREC(FACT:PATT[F],TTYALWAYS);
				$PRINT(" WAS ASSUMED TO BE TRUE, BUT MAY NOT BE"
					&CRLF,TTYALWAYS);
				END;
			END;
		END;
	END;

! mergein;

PROCEDURE MERGEIN(ITEMVAR IW,OW);
	BEGIN
	RPTR(FACT) F;
	INTEGER IWX,OWX;
	IWX←WLDINX(IW);OWX←WLDINX(OW);
	∀ | GEN_FACTS(F,OW) DO
		BEGIN
		IF ¬TSTWIX(F,IWX)∧FLUENT_FACT(F) THEN
			CLRWLD(F,OWX);
		END;
	∀ | GEN_FACTS(F,IW) DO
		BEGIN
		IF ¬TSTWIX(F,OWX)∧¬FLUENT_FACT(F) THEN
			SETWLD(F,OWX);
		END;
	END;
! cpattl;

LIST PROCEDURE CPATTL(RCELL C;ITEMVAR WLD;REFERENCE RCELL BL);
	BEGIN
	RANY V;
	ITEMVAR IV;
	INTEGER VTYP;
	LIST PL;
	BL←NULL_RECORD;
	PL←NIL;
	WHILE C≠NULL_RECORD DO
		BEGIN "CLOOP"
		V←CELL:CAR[C];
		VTYP←RECTYPE(V);
		IF VTYP=LOC(NOMV) THEN
			BEGIN
			! fetch nominal value;
			V←EVALEXPR(V,WLD);
			END
		ELSE IF VTYP=LOC(BINDV) THEN
			BEGIN
			BL←CONS(V,BL);
			IV←\(BINDV:RESULT[V])[1];
			∂(IV,INTEGER)←∂(IV,INTEGER) LOR BINDB;
			! **** BECAUSE OF A SAIL LOSSAGE *****;
			PL[∞+1]←IV;
			CONTINUE "CLOOP";
			END
		ELSE IF VTYP≠LOC(VARIABLE) THEN 
			USERERR(1,1,"CPATTL DOESN'T EXPECT AN ELEMENT OF TYPE "
					&CVRTS(VTYP));
		PL←PL&\($ V);
		C←CELL:CDR[C];
		END;
	RETURN(PL);
	END;
! asrtit & denyit;

INTERNAL PROCEDURE ASRTIT(RPTR(AFACT,SFACT) F;ITEMVAR IW,OW);
	BEGIN
	RCELL CC;
	IF RECTYPE(F)=LOC(AFACT) THEN
		BEGIN
		RPTR(EXPRN,VARIABLE) L;
		L←AFACT:LEFT[F];
		IF RECTYPE(L)≠LOC(VARIABLE)∨AFACT:RELN[F]≠0 THEN
			BEGIN
			$PRINT(CRLF,TTYYES);
			HALPRN(F,TTYYES);
			USERERR(1,1," asrtit given an afact it cannot handle"&crlf);
			RETURN;
			END
		ELSE
			CHANGE(L,EVALEXPR(AFACT:RIGHT[F],IW),OW);
		END
	ELSE IF RECTYPE(F)=LOC(SFACT) THEN
		BEGIN "SASSERT"
		LPASRT(OW,CPATTL(SFACT:PATT[F],IW,CC));
		IF CC≠NULL_RECORD THEN 
			USERERR(1,1,"BINDING ASSERTIT??");
		END
	ELSE
		USERERR(1,1,"ASRTIT CALLED WITH FUNNY FACT");
	END;

INTERNAL PROCEDURE DENYIT(RPTR(SFACT,AFACT) F;ITEMVAR IW,OW);
	BEGIN
	RANY CC;
	IF RECTYPE(F)=LOC(AFACT) THEN
		BEGIN
		RPTR(EXPRN,VARIABLE) L;
		L←AFACT:LEFT[F];
		IF RECTYPE(L)≠LOC(VARIABLE)∨AFACT:RELN[F]≠0 THEN
			BEGIN
			$PRINT(CRLF,TTYYES);
			HALPRN(F,TTYYES);
			USERERR(1,1," denyit given an afact it cannot handle"&crlf);
			RETURN;
			END
		ELSE
			BEGIN
			IF EXPEQV(EVALEXPR(L,IW),EVALEXPR(AFACT:RIGHT[F],IW)) THEN
				INVALIDATE(L,OW);
			END;
			
		END
	ELSE IF RECTYPE(F)=LOC(SFACT) THEN
		BEGIN "SDENY"
		LPDENY(OW,CPATTL(SFACT:PATT[F],IW,CC));
		IF CC≠NULL_RECORD THEN
			USERERR(1,1," binding denyit?? ");
		END
	ELSE
		USERERR(1,1,"DENYIT CALLED WITH FUNNY FACT");
	END;

! new_fluent, new_set_fluent, new_var, new_exprn, stmake, new_stmnt;

INTERNAL RANY FRTEMP;

INTERNAL RPTR(FLUENT) PROCEDURE NEW_FLUENT;
	BEGIN

	! creates a new fluent record & sets up pointers;

	RPTR(FLUENT) FL;
	FL←NEW_RECORD(FLUENT);
	FLUENT:RETRPATT[FL]←PATTBLK(\($ FL,BIND FRTEMP));
	RETURN(FL);
	END;

INTERNAL RPTR(SET_FLUENT) PROCEDURE NEW_SET_FLUENT;
	BEGIN
	RPTR(SET_FLUENT) SFL;
	SFL←NEW_RECORD(SET_FLUENT);
	SET_FLUENT:RETRPATT[SFL]←PATTBLK(\($ SFL,BIND FRTEMP));
	RETURN(SFL);
	END;


INTERNAL RPTR(VARIABLE) PROCEDURE NEW_VAR(RANY ITEMVAR IV;INTEGER DT);
	BEGIN
	RPTR(VARIABLE) VAR;
	VAR←NEW_RECORD(VARIABLE);
	VARIABLE:PLNVAL[VAR]←NEW_FLUENT;
	VARIABLE:CALCS[VAR]←NEW_SET_FLUENT;
	VARIABLE:DEPS[VAR]←NEW_SET_FLUENT;
	VARIABLE:CHANGERS[VAR]←NEW_SET_FLUENT;
	VARIABLE:NAME[VAR]←IV;
	∂(IV)←VAR;
	VARIABLE:DATATYPE[VAR]←DT;
	RETURN(VAR);
	END;

INTERNAL RPTR(EXPRN) PROCEDURE NEW_EXPRN(INTEGER DT,OP;RCELL ARGS);
	BEGIN
	RPTR(EXPRN) E;
	E←NEW_RECORD(EXPRN);
	EXPRN:DATATYPE[E]←DT;
	EXPRN:OP[E]←OP;
	EXPRN:ARGS[E]←ARGS;
	RETURN(E);
	END;

INTERNAL RPTR(STMNT) PROCEDURE STMAKE(RSSS SEM(NULL_RECORD));
	BEGIN
	RPTR(STMNT) S;
	S←NEW_RECORD(STMNT);
	STMNT:SEMANTICS[S]←SEM;
	STMNT:ID[S]←NEW(S);
	RETURN(S);
	END;

INTERNAL RPTR(STMNT) PROCEDURE NEW_STMNT(ITEMVAR IW,OW; RSSS SEM);
	BEGIN
	RPTR(STMNT) S;
	S←STMAKE(SEM);
	STMNT:IW[S]←IW;
	STMNT:OW[S]←OW;
	RETURN(S);
	END;

! domove;

RECURSIVE PROCEDURE DOMOVE(RPTR(STMNT) S);
	BEGIN			
	RPTR(VARIABLE) F,A;
	RCELL C;
	RANY ONM;
	RPTR(MOVE$) MS;
	ITEMVAR IW,OW;
	! this routine doesn't do the right thing in cases
	where FRAME is not the controllable frame.  Consult
	with RF on what to do about all this.  ;
		
	IW←STMNT:IW[S];OW←STMNT:OW[S];
	CPYWLD(IW,OW);
	MS ← STMNT:SEMANTICS[S];   !  Added by RF;
	CHANGE(MOVE$:WHAT[MS],EVALEXPR(MOVE$:DEST[MS],OW),OW);
	C←MOVE$:CLAUSES[MS];
	WHILE C≠NULL_RECORD DO
		BEGIN
		RANY ONST;
		ONST←CELL:CAR[C]; C←CELL:CDR[C];
		IF RECTYPE(ONST)≠LOCATION(CMON) THEN CONTINUE;
		STINTERP(STMCHK(CMON:CONCLUSION[ONST]));
		ANDWLD(STMNT:OW[ONST],OW,OW);
		END;


	END;

! do_affix, do_affix_stmnt, do_detach;

INTERNAL PROCEDURE DO_AFFIX(RVAR F1,F2,BV;REXPR AE;RVAR RGF;ITEMVAR IW,OW);
	BEGIN
	RANY ASTN;
	RPTR(FACT) ITEMVAR FCTI;
	RPTR(TRANS) T;
	ITEMVAR IV;
	CHANGE(BV,T←EVALEXPR(AE,IW),OW);
	ASTN←PATTBLK(\($ AFFIXED,
			$ F1,
			$ F2,
			$ BV,
			$ T,
			$ RGF) );
	IF PMATCH(ANY,ASTN,TRUE) THEN
		BEGIN
		SETWLD(_FACT_,WLDINX(OW));
		RETURN;
		END;
	FCTI←FACT:ID[ASRTPF(OW,ASTN)];
	MAKE F1CALC⊗FCTI≡NEW(
		ADDCALC(F1,NEW_EXPRN(FRAME_DTYPE,TFMUL_OP,LIST2(BV,F2)),OW));
	IF RGF=RIGIDLY THEN
		BEGIN
		! f1 <= bv*f2  , f2 <= inv(bv)*f1;
		MAKE F2CALC⊗FCTI≡NEW(
			ADDCALC(F2,NEW_EXPRN(FRAME_DTYPE,TFMUL_OP,
				  LIST2(NEW_EXPRN(TRANS_DTYPE,TINVRT_OP,
					CONS(BV,NULL_RECORD)),F1)),OW));
		END
	ELSE
		BEGIN

		! f1 <= bv*f2 ... when_changing f1 also do bv←(f2→new) ;

		RPTR(ASSIGNMENT) ASG;
		RPTR(STMNT) CHG;

		ASG←NEW_RECORD(ASSIGNMENT);
		ASSIGNMENT:VAR[ASG]←BV;
		ASSIGNMENT:VAL[ASG]←NEW_EXPRN(TRANS_DTYPE,
					      FTOF_OP,
					      LIST2(F2,VNEWTRANS));
		CHG←NEW_RECORD(STMNT);
		STMNT:SEMANTICS[CHG]←ASG;
		MAKE CHNGR⊗FCTI≡NEW(CHG); !  *** replace all this with relies-on;
		PUT_SET_FLUENT(OW,VARIABLE:CHANGERS[F1],CHG);
		END;

	END;

PROCEDURE DO_AFFIX_STMNT(RSTMNT S);
	BEGIN
	ITEMVAR IW,OW;
	RPTR(AFFIX) A;
	REXPR AE;
	RVAR BV,F1,F2;
	IW←STMNT:IW[S];
	OW←STMNT:OW[S];
	CPYWLD(IW,OW);
	
	A←STMNT:SEMANTICS[S];

	F1←AFFIX:FRAME1[A];
	F2←AFFIX:FRAME2[A];

	BV←AFFIX:BYVAR[A];
	IF BV=NULL_RECORD THEN
		BEGIN
		BV←NEW_VAR(NEW(NULL_RECORD),TRANS_DTYPE);
		AFFIX:BYVAR[A]←BV;
		NEW_PNAME(VARIABLE:NAME[BV],"VAR"&CVS(VARNO));
		VARNO←VARNO+1;
		END;
	
	AE←AFFIX:ATEXP[A];
	IF AE=NULL_RECORD THEN
		AE←AFFIX:ATEXP[A]←NEW_EXPRN(TRANS_DTYPE,FTOF_OP,LIST2(F2,F1));
	DO_AFFIX(F1,F2,BV,AE,AFFIX:RIGID[A],IW,OW);
	END;

INTERNAL PROCEDURE DO_DETACH(RVAR F1,F2;ITEMVAR IW,OW);
	BEGIN
	RVAR BV,RGF;
	RPTR(TRANS) T;
	∀ | LPMATCH(IW,\($ AFFIXED,$ F1,$ F2,
					BIND BV,
					BIND T,
					BIND RGF)) DO
		BEGIN
		RPTR(FACT) ITEMVAR FCTI;
		RPTR(CALCULATOR,PROC_FORM) ITEMVAR CI;
		FCTI←FACT:ID[_FACT_];
		
		CLRWLD(_FACT_,WLDINX(OW));
		IF CHNGR⊗FCTI≡BIND CI THEN
			REM_SET_FLUENT(OW,VARIABLE:CHANGERS[F1],∂(CI));
		IF F1CALC⊗FCTI≡BIND CI THEN
			REM_SET_FLUENT(OW,VARIABLE:CALCS[F1],∂(CI));
		IF F2CALC⊗FCTI≡BIND CI THEN
			REM_SET_FLUENT(OW,VARIABLE:CALCS[F2],∂(CI));
		END;
	END;
! blockdo & sttblk;

RECPROC BLOCKDO(RPTR(STMNT) S);
	BEGIN
	ITEMVAR IW;
	RCELL C;
	C←BLOCK:CODE[STMNT:SEMANTICS[S]];
	IW←STMNT:IW[S];
	WHILE C≠NULL_RECORD DO
		BEGIN
		INTEGER ST;
		ST←RECTYPE(CELL:CAR[C]);
		IF ST=LOC(STMNT) THEN
			BEGIN
			STINTERP(CELL:CAR[C]);
			IW←STMNT:OW[CELL:CAR[C]];
			END
		ELSE IF ST=LOC(PVL) THEN
			PVLDO(PVL:VL[CELL:CAR[C]],IW)
		ELSE IF ST=LOC(VARIABLE) THEN
			BEGIN
			END
		ELSE IF ST=LOC(DBD) THEN
			WLDDMP(DBD:WLD[CELL:CAR[C]])
		ELSE IF ST=LOC(NW) THEN
			BEGIN
			END
		ELSE
			BEGIN
			USERERR(1,1,"FUNNY BLOCK ELEMENT");
			END;
		C←CELL:CDR[C];
		END;
	END;

INTERNAL RPTR(BLOCK) PROCEDURE STTBLK(RANY S);
	BEGIN
	RPTR(BLOCK) B;
	IF RECTYPE(S)≠LOC(BLOCK) THEN
		BEGIN
		B←NEW_RECORD(BLOCK);
		BLOCK:CODE[B]←CONS(S,NULL_RECORD);
		RETURN(STMAKE(B));
		END;
	RETURN(S);
	END;
! Cobdo;

RECPROC COBDO(RPTR(STMNT) S);
	BEGIN
	RCELL C;
	BOOLEAN FLAG;
	RPTR(STMNT) SS;
	C←COBLOCK:CODE[CHKREC(STMNT:SEMANTICS[S],LOC(COBLOCK))];
	FLAG←FALSE;
	WHILE C≠NULL_RECORD DO
		BEGIN
		SS←STMCHK(CELL:CAR[C]);
		CPYWLD(STMNT:IW[S],STMNT:IW[SS]);
		STINTERP(SS);
		IF FLAG THEN
			MERGEIN(STMNT:OW[SS],STMNT:OW[S])
		ELSE
			BEGIN
			FLAG←TRUE;
			CPYWLD(STMNT:OW[SS],STMNT:OW[S]);
			END;
		C←CELL:CDR[C];
		END;
	IF ¬FLAG THEN
		CPYWLD(STMNT:IW[S],STMNT:OW[S]);
	END;

! loopbdo;

RECPROC LOOPBDO(RPTR(STMNT) S);
	BEGIN
	CALL_ALERT(STMNT:IW[S]);
	STINTERP(S);
	CHECK_GUARDS(STMNT:IW[S],STMNT:OW[S]);
	END;

! statement interpreter: stinterp (owdo, iwcopy);

INTERNAL RECPROC STINTERP(RPTR(STMNT) S);
	BEGIN
        !  Takes the statement S and interprets what it would do to
        the world.  The worlds associated with S are actually
        modified;
	INTEGER STYP;
	ITEMVAR IW,OW;
	RSSS SS;
	RPTR(STMNT) S1,S2;

	PROCEDURE OWDO;
		CPYWLD(IW,OW);

	SIMPLE PROCEDURE IWCOPY(RPTR(STMNT) SX);
		CPYWLD(IW,STMNT:IW[SX]);
		
	IF STITRC LAND '1 THEN
		$PRINT(CRLF&"STATEMENT TYPE ="&CVOS(STYP));
	IF STITRC LAND '2 THEN
		BEGIN
		$PRINT(CRLF&"STATEMENT RECORD =");
		HALPRN(S);
		END;

	IF S=NULL_RECORD THEN 
		RETURN;

	IF RECTYPE(S) ≠ LOC(STMNT)
	    THEN BEGIN  ! Added by RF;
	    USERERR(1,1,"STINTERP:  Not a statement");
	    RETURN;
	    END;

	IF ¬UNBOUND(STMNT:PRC[S]) THEN
		BEGIN
		DEFINE PREDICT_EFFECTS_REC "[]" = "RPEFCT";
		EXTERNAL RANY PREDICT_EFFECTS_REC;
		! defined in RHTREC;
		REC_RESUME(STMNT:PRC[S],PREDICT_EFFECTS_REC);
		RETURN;
		END;

	SS←STMNT:SEMANTICS[S];
	IF SS=NULL_RECORD THEN RETURN;
	STYP←RECTYPE(SS);

	IW←STMNT:IW[S];
	OW←STMNT:OW[S];
	
	IF STYP=LOC(BLOCK) THEN
		BLOCKDO(S)
	ELSE IF STYP=LOC(ASSIGNMENT) THEN
		BEGIN
		OWDO;
		CHANGE(ASSIGNMENT:VAR[SS],
			EVALEXPR(ASSIGNMENT:VAL[SS],OW),OW);
		! note that this is OW now (so side effects happen);
		END
	ELSE IF STYP=LOC(GASSIGN) THEN
		BEGIN
		OWDO;
		INVALIDATE(GASSIGN:VAR[SS],OW);
		CASE GASSIGN:OP[SS] OF
			BEGIN
		[1]	ADDCALC(GASSIGN:VAR[SS],GASSIGN:EXP[SS],OW);
		[2]	KILLCALC(GASSIGN:VAR[SS],GASSIGN:EXP[SS],OW);
		[3]	ONLYCALC(GASSIGN:VAR[SS],GASSIGN:EXP[SS],OW);
		[0]	USERERR(1,1,"ILLEGAL GRAPH ASSIGNMENT OP")
			END;
		END
	ELSE IF STYP=LOC(IFF) THEN
		BEGIN
		! here need code to handle conditional;
		S1←STMCHK(IFF:THN[SS]);
		S2←STMCHK(IFF:ELS[SS]);
		IWCOPY(S1);
		IWCOPY(S2);
		STINTERP(S1);
		STINTERP(S2);
		ANDWLD(STMNT:OW[S1],STMNT:OW[S2],OW);
		END
	ELSE IF STYP=LOC(COBLOCK) THEN
		BEGIN
		COBDO(S);
		END
	ELSE IF STYP=LOC(WHIL) THEN
		BEGIN
		S1←STMCHK(WHIL:BODY[SS]);
		IWCOPY(S1);
		LOOPBDO(S1);
		ANDWLD(STMNT:OW[S1],IW,OW);
		END
	ELSE IF STYP=LOC(FORR) THEN
		BEGIN  !  Added by RF;
		S1←STMCHK(FORR:BODY[SS]);
		IWCOPY(S1);
		LOOPBDO(S1);
		ANDWLD(STMNT:OW[S1],IW,OW);
		END
	ELSE IF STYP=LOC(ASSERT) THEN
		BEGIN
		OWDO;
		ASRTIT(ASSERT:FACT[SS],IW,ASSERT:WLD[SS]);
		END
	ELSE IF STYP=LOC(DENY) THEN
		BEGIN
		OWDO;
		DENYIT(DENY:FACT[SS],IW,DENY:WLD[SS]);
		END
	ELSE IF STYP=LOC(AFFIX) THEN
		BEGIN
		DO_AFFIX_STMNT(S);
		END
	ELSE IF STYP=LOC(NW) THEN
		OWDO
	ELSE IF STYP = LOC(MOVE$) THEN
		BEGIN "move"
		DOMOVE(S);
		END "move"

	ELSE IF STYP = LOC(COMMNT) THEN
		BEGIN "commnt"  !  Added by RF;
		OWDO;
		END "commnt"
	ELSE IF STYP = LOC(ALSODO) THEN
		BEGIN "alsodo"  !  Added by RF;
		OWDO;	! Temporarily does nothing;
		END "alsodo"
	ELSE IF STYP = LOC(CMON) THEN
		BEGIN  "cmon"  ! Added by RF;
		OWDO;  ! Temporarily does nothing;
		END "cmon"
	ELSE IF STYP = LOC(EVDO) THEN
		BEGIN  "evdo"  ! Added by RF;
		OWDO;  ! Temporarily does nothing;
		END "evdo"
	ELSE IF STYP = LOC(PROG) THEN	!  added by RF;
		STINTERP(PROG:CODE[SS])
	ELSE
		BEGIN
		$PRINT(CRLF&"***");
		HALPRN(SS);
		USERERR(1,1," STINTERP GIVEN A STATEMENT TYPE IT CANNOT HANDLE");
		END;
	END;

! proc_form interpreter:  apfrm, apfrm2;

INTERNAL RECPROC APFRM(RPTR(PROC_FORM) PF;RCELL VL);
	BEGIN
	RCELL PFFPL;
	PFFPL←PROC_FORM:FPS[PF];
	WHILE PFFPL≠NULL_RECORD ∧ VL≠NULL_RECORD DO
		BEGIN
		VCELL:VAL[CELL:CAR[PFFPL]]←CELL:CAR[VL];
		PFFPL←CELL:CDR[PFFPL];
		VL←CELL:CDR[VL];
		END;
	STINTERP(PROC_FORM:S[PF]);
	END;

INTERNAL RECPROC APFRM2(RPTR(PROC_FORM) PF;RPTR(VALU$) V1,V2);
	BEGIN
	RCELL PFFPL;
	RPTR(VALU$) V;
	PFFPL←PROC_FORM:FPS[PF];
	FOR V←V1,V2 DO
		BEGIN
		IF PFFPL=NULL_RECORD THEN DONE;
		VCELL:VAL[CELL:CAR[PFFPL]]←V;
		PFFPL←CELL:CDR[PFFPL];
		END;
	STINTERP(PROC_FORM:S[PF]);
	END;

! test program;

IFCR TRUE THENC
INTERNAL PROCEDURE WMTEST;
     WHILE TRUE DO
	BEGIN
	REQUIRE "GOBBLE.HDR[HAL,RHT]" SOURCE_FILE;
	INTEGER NF;
	RCELL SE;
	RANY ST;
	RPTR(STMNT) BS;
	SE←READ;
	ST←GROVEL(SE);
	BS←STTBLK(ST);
	NF←TRUE;
	WLDASG(BS,CURWLD,CURWLD,NF);
	HALPRN(BS);
	$PRINT(CRLF);
	STINTERP(BS);
	END;
ENDC

END $$PRGID;